home *** CD-ROM | disk | FTP | other *** search
/ Amiga Collections: MegaDisc / MegaDisc 28 (1992-05)(MegaDisc Digital Publishing)(AU)(Disk 2 of 2).zip / MegaDisc 28 (1992-05)(MegaDisc Digital Publishing)(AU)(Disk 2 of 2).adf / Programming / BASIC_TUTORIAL_9 / diskfont.bas < prev    next >
BASIC Source File  |  1992-05-26  |  15KB  |  490 lines
  1. 'BASIC for the Amiga
  2.  
  3. 'Chapter Nine   Diskfont.bas
  4.  
  5. 'Purpose      - How to Get a Disk Font and use it
  6.  
  7. 'Commands     - LIBRARY, DECLARE FUNCTION, LIBRARY CLOSE
  8.  
  9. '               LOCATE,  PRINT,  FOR...NEXT,  INPUT,  END
  10.  
  11. '             - OpenFont, CloseFont, AskSetStyle, SetStyle
  12.  
  13. '             - SetFont, enable, pFont
  14.  
  15. 'SUB PROGRAMS - Font, SetStyle
  16.  
  17. 'Author       - Frank Wilkinson
  18.  
  19. LIBRARY "diskfont.library"
  20. LIBRARY "graphics.library"
  21. DECLARE FUNCTION OpenDiskFont& LIBRARY
  22. DECLARE FUNCTION OpenFont& LIBRARY
  23. DECLARE FUNCTION AskSoftStyle& LIBRARY
  24. SCREEN 1,640,256,3,2
  25. WINDOW 2,"DiskFonts",,,1
  26.  
  27.  FOR q = 0 TO 7
  28.  READ r,g,b
  29.  PALETTE q,r/16,g/16,b/16
  30.  NEXT q
  31.  DATA 0,0,0, 0,1,12, 7,0,0, 0,7,0, 5,5,0, 5,5,9, 8,0,15, 7,7,7
  32.  
  33. CLS
  34. LOCATE 2,1
  35. a$(1)="Emerald":a$(2)="Diamond":a$(3)="Ruby":a$(4)="Sapphire"
  36. a$(5)="Garnet":a$(6)="Topaz":count=0
  37. FOR x=1 TO 6
  38. Font a$(x)+".font",19,0,0
  39. GOSUB FontFound
  40. NEXT x
  41. PRINT count
  42. IF count=6 THEN
  43. PRINT "You have all the Fonts in the Fonts Drawer. "
  44. END IF
  45.  
  46. GOSUB PageTurn
  47. CLS
  48. GOTO Demo
  49.  
  50. FontFound:
  51. IF pfont&<>0 THEN
  52. Font "topaz.font",8,0,0
  53. PRINT a$(x)".font found"
  54. count=count+1
  55. ELSE
  56. Font "topaz.font",8,0,0
  57. PRINT a$(x)".font not found"
  58. END IF
  59. RETURN
  60. GOSUB PageTurn
  61.  
  62. Demo:  ' Demonstration of Font Command
  63.        LOCATE 4,1
  64.        Font "Sapphire.font", 19,0,0
  65.        enable%=AskSoftStyle&(WINDOW(8))
  66.        SetStyle 2
  67.        LOCATE 2,12:COLOR 5,0
  68.        PRINT "Basic Tutorial"
  69.        Font "Sapphire.font",14,0,0
  70.        COLOR 4,0
  71.        PRINT "                       Chapter 9"
  72.        PRINT "                           by"
  73.        PRINT "                     Frank Wilkinson"
  74.        COLOR 1,0
  75.        Font "topaz.font",8,0,0
  76.        LOCATE 15,1
  77.        PRINT "                    Demonstration of how to obtain"
  78.        PRINT "                               and use"
  79.        PRINT "                     the FONTS on your System Disk"
  80.        GOSUB PageTurn
  81.        CLS
  82.        Font "Sapphire.font", 19,0,0
  83.        SetStyle 3
  84.        PRINT:PRINT:COLOR 3,0
  85.        PRINT "This is Sapphire 19 Points, Bold and Underlined"
  86.        PRINT "Each line of this Font occupies 19 Screen lines."
  87.        FOR de=1 TO 1000:NEXT de
  88.  
  89.        Font "Diamond.font", 20,0,0
  90.        COLOR 4,0
  91.        PRINT "...another TextFont...    Diamond 20"
  92.        PRINT "This Font occupies 20 Screen lines."
  93.        FOR de=1 TO 1000:NEXT de
  94.  
  95.        Font "Emerald.font", 20,0,0
  96.        COLOR 3,0
  97.        PRINT "...and yet another!  Amiga has still more!"
  98.        PRINT "Emerald 20 occupies 20 Screen lines."
  99.        FOR de=1 TO 1000:NEXT de
  100.  
  101.        Font "RUBY.font", 15,0,0
  102.        COLOR 2,0
  103.        PRINT "This is RUBY and it occupies 15 screen lines."
  104.        FOR de=1 TO 1000:NEXT de
  105.  
  106.        Font "Garnet.font", 16,0,0
  107.        PRINT "This is GARNET 16 and it occupies 16 screen lines."
  108.        FOR de=1 TO 1000:NEXT de
  109.  
  110.        Font "topaz.font", 8,0,0
  111.        GOSUB PageTurn
  112.  
  113.        CLS
  114.        LINE (0,19)-(615,19),4
  115.        Font "Diamond.font", 20,0,0
  116.        LOCATE 2,1:COLOR 3,0
  117.        PRINT "Diamond 20"
  118.        LOCATE 2,8
  119.        Font "topaz.font", 8,0,0
  120.        PRINT "and Topaz 8 both on the same screen line"
  121.        Font "Diamond.font", 20,0,0
  122.        LOCATE 2,25
  123.        PRINT "Diamond 20"
  124.        LINE (0,39)-(615,39),4
  125.        Font "topaz.font", 8,0,0
  126.        PRINT:PRINT"The lines show the area occupied by the Diamond font."
  127.        PRINT
  128.        PRINT "This is the command you use to get a DiskFont."
  129.        PRINT
  130.        COLOR 4,0
  131.        PRINT "          Font ";CHR$(34);"Diamond.font";CHR$(34);", 20,0,0"
  132.        COLOR 1,0
  133.        PRINT
  134.        PRINT "And this is the command you use to Set the Style."
  135.        PRINT
  136.        COLOR 4,0
  137.        PRINT "        enable%=AskSoftStyle&(WINDOW(8))"
  138.        PRINT "        SetStyle 1"
  139.  
  140.        GOSUB PageTurn
  141.        CLS:COLOR 1,0
  142.        PRINT "This is the SUB Program which calls a DiskFont."
  143.        PRINT:COLOR 4,0
  144.        PRINT "       SUB Font(fontName$, height%, style%, prefs%) STATIC"
  145.        PRINT "         SHARED pFont&"
  146.        PRINT "         IF pFont&<>0 THEN CALL CloseFont(pFont&)"
  147.        PRINT "         fontName0$=fontName$+CHR$(0)"
  148.        PRINT "         textAttr&(0)=SADD(fontName0$)"
  149.        PRINT "         textAttr&(1)=height%*65536& + style%*256 + prefs%"
  150.        PRINT "         pFont&=OpenDiskFont&(VARPTR(textAttr&(0)))"
  151.        PRINT "         IF pFont& <> 0 THEN SetFont WINDOW(8),pFont&"
  152.        PRINT "       END SUB"
  153.        PRINT:COLOR 1,0
  154.        PRINT "And this SUB Program Sets the Style"
  155.        PRINT:COLOR 4,0
  156.        PRINT "       SUB SetStyle(mask%) STATIC"
  157.        PRINT "         SHARED enable%"
  158.        PRINT "         SetSoftStyle WINDOW(8),mask%,enable%"
  159.        PRINT "       END SUB"
  160.        COLOR 1,0
  161.  
  162.        GOSUB PageTurn
  163.  
  164.        CLS
  165.        FOR x=7 TO 192 STEP 8
  166.        LINE (0,x)-(615,x),1
  167.        NEXT x
  168.        LOCATE 10,1
  169.        COLOR 3,0
  170.        PRINT "This is Text Line 10"
  171.        PRINT :PRINT "Note the empty Screen line under this TEXT."
  172.        SetStyle 1
  173.        PRINT "This screen line is used if the SoftStyle underline is used."
  174.        SetStyle 0
  175.        PRINT "It is also used for the tail of the letters 'y g p q."
  176.        PRINT "Because the LINE command was used before the TEXT was PRINTed"
  177.        PRINT "the empty line under each letter overwrites the line on the"
  178.        PRINT "screen. Now see what happens if the LINE command comes after"
  179.        PRINT "the TEXT. Take careful note of the letters 'y g p q'"
  180.        GOSUB PageTurn
  181.  
  182.        CLS
  183.        LOCATE 10,1
  184.        PRINT "This is Text Line 10."
  185.        PRINT
  186.        PRINT "As you can see the LINES have been drawn in the empty Screen"
  187.        PRINT "line at the bottom of each letter."
  188.        SetStyle 1
  189.        PRINT "Here are the letters Yy Gg Pp Qq."
  190.        SetStyle 0
  191.        PRINT "The TOPAZ FONT occupies all of the 8 pixels of its Point Size"
  192.        PRINT "therefore the line command will overwrite the curly bit at the"
  193.        PRINT "bottom of the letter and any underlining that may be there."
  194.        PRINT
  195.        PRINT
  196.        LOCATE 28,15:INPUT "Press RETURN to draw the lines.",dum$
  197.  
  198.        FOR x=7 TO 192 STEP 8
  199.        LINE (0,x)-(615,x),1
  200.        NEXT x
  201.        GOSUB PageTurn
  202.  
  203.        CLS
  204.        Font "Diamond.font", 20,0,0
  205.        LOCATE 2,1
  206.        PRINT "Diamond 20"
  207.        FOR x=19 TO 192 STEP 20
  208.        LINE (0,x)-(615,x),1
  209.        NEXT x
  210.        PRINT "This is Diamond again."
  211.        PRINT "The LINES are drawn at 20 screen line"
  212.        PRINT "Intervals. The top of the letter is"
  213.        PRINT "At the very top of its 20 points."
  214.        PRINT "More space is left for the 'y g p and q."
  215.        GOSUB PageTurn
  216.  
  217.        CLS
  218.        LOCATE 2,1
  219.        SetStyle 1
  220.        PRINT "Diamond 20"
  221.        PRINT "This is Diamond again.Now Underlined. The LINES are "
  222.        PRINT "drawn at 20 screen line Intervals. The top of the letter is"
  223.        PRINT "at the very top of its 20 points. More space is left for the "
  224.        PRINT "'y g p and q. The curly bits are overwritten again."
  225.        PRINT "But notice where the underlining occurs."
  226.        FOR x=19 TO 192 STEP 20
  227.        LINE (0,x)-(615,x),1
  228.        NEXT x
  229.        Font "topaz.font", 8,0,0
  230.        GOSUB PageTurn
  231.  
  232.        SetStyle 0
  233.        Font "RUBY.font", 15,0,0
  234.        CLS
  235.        FOR x= 4 TO 640 STEP 5
  236.        LINE (x,0)-(x,256),1
  237.        NEXT x
  238.        FOR Y = 14 TO 256 STEP 15
  239.        LINE(0,Y)-(640,Y),1
  240.        NEXT Y
  241.        LOCATE 2,5: PRINT "A"
  242.        LOCATE 2,10:PRINT "a"
  243.        LOCATE 4,5:PRINT "B"
  244.        LOCATE 4,10:PRINT "b"
  245.        SetStyle 3
  246.        LOCATE 2,15: PRINT "A"
  247.        LOCATE 2,20:PRINT "a"
  248.        LOCATE 4,15:PRINT "B"
  249.        LOCATE 4,20:PRINT "b"
  250.        LOCATE 2,25:PRINT "I"
  251.        LOCATE 2,30:PRINT "i"
  252.        SetStyle 0
  253.        PRINT
  254.        PRINT "The Screen is now divided into 5 x 15 Squares. RUBY"
  255.        PRINT
  256.        PRINT "is a 15 point font. See if you can count how many"
  257.        PRINT
  258.        PRINT " pixels each letter occupies."
  259.        PRINT
  260.        Font "topaz.font",8,0,0
  261.  
  262.        PRINT "The Capital letters are fairly  wide and the lowercase letters"
  263.        PRINT "vary some 10 others less. This is a PROPORTIONAL font."
  264.        Font "",0,0,0  'Causes last pFont to be closed
  265.        GOSUB PageTurn
  266.        Font "topaz.font",11,0,0
  267.        CLS
  268.        FOR x= 7 TO 640 STEP 8
  269.        LINE (x,0)-(x,256),1
  270.        NEXT x
  271.        FOR Y =10 TO 256 STEP 11
  272.        LINE(0,Y)-(640,Y),1
  273.        NEXT Y
  274.        PRINT
  275.        PRINT "This is Topaz 11 and the screen is divided into 8 x 11 pixel rectangles."
  276.        PRINT
  277.        PRINT "As you can see this, like its little brother topaz 8,is not PROPORTIONAL."
  278.        PRINT
  279.        PRINT "Every letter occupies the same number of pixels Across (8) and Down (11)."
  280.        PRINT
  281.        Font "topaz.font", 9,0,0
  282.        PRINT "This line is Topaz 9 and it is not the same width as Topaz 11."
  283.        PRINT
  284.        PRINT "And not as Tall."
  285.        PRINT
  286.        Font "topaz.font",8,0,0
  287.        PRINT "This line is Topaz 8 and it is the same width as Topaz 11."
  288.        PRINT
  289.        PRINT "But not as Tall as 9."
  290.        PRINT
  291.        GOSUB PageTurn
  292.  
  293.  
  294. ls=1461
  295. DIM CHECK(64)
  296.  DIM p%(1461)
  297. MakeLetter:
  298.  
  299.        CLS
  300.        PRINT:PRINT "How an Eight Point letter is formed"
  301.        x=100:Y=50:box=10
  302.        FOR D=0 TO 8
  303.        LINE (x,Y+D*box)-(x+80,Y+D*box),3
  304.        NEXT D
  305.        FOR D=0 TO 8
  306.        LINE (x+D*box,Y)-(x+D*box,Y+80),3
  307.        NEXT D
  308.        LINE (100,50)-(170,60),2,BF
  309.        LINE (110,60)-(130,110),2,BF
  310.        LINE (100,110)-(140,120),2,BF
  311.        LINE (130,80)-(160,90),2,BF
  312.        LINE (160,60)-(170,70),2,BF
  313.        box=10
  314.        nbox=8
  315.        size=box*nbox
  316. CL2:
  317. FOR CH=0 TO 64
  318.  CHECK(CH)=0
  319. NEXT CH
  320.        x=200:Y=50
  321.        X2=x+size:Y2=Y+size
  322.        FOR D=0 TO nbox
  323.          LINE (x,Y+D*box)-(X2,Y+D*box),2
  324.        NEXT D
  325.        FOR D=0 TO nbox
  326.          LINE (x+D*box,Y)-(x+D*box,Y2),2
  327.        NEXT D
  328.        LINE (400,20)-(450,45),5,b
  329.        LINE (400,50)-(450,75),5,b
  330.        LINE (500,141)-(380,161),4,b
  331.        LOCATE 19,52:PRINT"Clear the"
  332.        LOCATE 20,52:PRINT " box"
  333.        LOCATE 4,52:PRINT "TRY"
  334.        LOCATE 5,52:PRINT "IT"
  335.        LOCATE 8,52:PRINT "END"
  336.        LOCATE 9,52:PRINT "IT"
  337.        LOCATE 24,1:PRINT"The RED box is yours to play with. Click in one of the"
  338.        PRINT "squares to fill it in. Click in it again to delete it."
  339.        PRINT "Click in the TRY IT box and you will be given the chance to Save"
  340.        PRINT "The shape to a file.If you don't wish to save it just press RETURN."
  341.        PRINT "Click in the END IT box when you have finished."
  342.  
  343.         FOR C=0 TO 8
  344.  
  345. WL2:
  346.         xx=0
  347.         WHILE xx=0
  348.                 xx=MOUSE(0)
  349.                 x$="":x$=INKEY$
  350.         WEND:WHILE MOUSE(0)<>0:WEND:S=MOUSE(1):T=MOUSE(2)
  351.         IF S>400 AND S<450 AND T>20 AND T<45 THEN GOTO SaveLetter
  352.         IF S>400 AND S<450 AND T>50 AND T<75 THEN GOTO ENDIT
  353.         IF S>400 AND S>141 THEN Z=0: GOTO ClearBox
  354.  
  355.         IF S>=200 AND S<280 AND T>=51 AND T<59 THEN D=0:GOTO PLACE
  356.         IF S>=200 AND S<280 AND T>=61 AND T<69 THEN D=1:GOTO PLACE
  357.         IF S>=200 AND S<280 AND T>=71 AND T<79 THEN D=2:GOTO PLACE
  358.         IF S>=200 AND S<280 AND T>=81 AND T<89 THEN D=3:GOTO PLACE
  359.         IF S>=200 AND S<280 AND T>=91 AND T<99 THEN D=4:GOTO PLACE
  360.         IF S>=200 AND S<280 AND T>=101 AND T<109 THEN D=5:GOTO PLACE
  361.         IF S>=200 AND S<280 AND T>=111 AND T<119 THEN D=6:GOTO PLACE
  362.         IF S>=200 AND S<280 AND T>=121 AND T<129 THEN D=7:GOTO PLACE
  363.  
  364.  
  365. PLACE:
  366.         IF S>=(201) AND S<=(209) AND CHECK((D*8)+1)=0 THEN COL=3:CHECK((D*8)+1)=1:C=0:GOTO LineDraw
  367.         IF S>=(211) AND S<=(219) AND CHECK((D*8)+2)=0 THEN COL=3:CHECK((D*8)+2)=1:C=1:GOTO LineDraw
  368.         IF S>=(221) AND S<=(229) AND CHECK((D*8)+3)=0 THEN COL=3:CHECK((D*8)+3)=1:C=2:GOTO LineDraw
  369.         IF S>=(231) AND S<=(239) AND CHECK((D*8)+4)=0 THEN COL=3:CHECK((D*8)+4)=1:C=3:GOTO LineDraw
  370.         IF S>=(241) AND S<=(249) AND CHECK((D*8)+5)=0 THEN COL=3:CHECK((D*8)+5)=1:C=4:GOTO LineDraw
  371.         IF S>=(251) AND S<=(259) AND CHECK((D*8)+6)=0 THEN COL=3:CHECK((D*8)+6)=1:C=5:GOTO LineDraw
  372.         IF S>=(261) AND S<=(269) AND CHECK((D*8)+7)=0 THEN COL=3:CHECK((D*8)+7)=1:C=6:GOTO LineDraw
  373.         IF S>=(271) AND S<=(279) AND CHECK((D*8)+8)=0 THEN COL=3:CHECK((D*8)+8)=1:C=7:GOTO LineDraw
  374.  
  375.         IF S>=(201) AND S<=(209) AND CHECK((D*8)+1)=1 THEN COL=0:CHECK((D*8)+1)=0:C=0:GOTO LineDraw
  376.         IF S>=(211) AND S<=(219) AND CHECK((D*8)+2)=1 THEN COL=0:CHECK((D*8)+2)=0:C=1:GOTO LineDraw
  377.         IF S>=(221) AND S<=(229) AND CHECK((D*8)+3)=1 THEN COL=0:CHECK((D*8)+3)=0:C=2:GOTO LineDraw
  378.         IF S>=(231) AND S<=(239) AND CHECK((D*8)+4)=1 THEN COL=0:CHECK((D*8)+4)=0:C=3:GOTO LineDraw
  379.         IF S>=(241) AND S<=(249) AND CHECK((D*8)+5)=1 THEN COL=0:CHECK((D*8)+5)=0:C=4:GOTO LineDraw
  380.         IF S>=(251) AND S<=(259) AND CHECK((D*8)+6)=1 THEN COL=0:CHECK((D*8)+6)=0:C=5:GOTO LineDraw
  381.         IF S>=(261) AND S<=(269) AND CHECK((D*8)+7)=1 THEN COL=0:CHECK((D*8)+7)=0:C=6:GOTO LineDraw
  382.         IF S>=(271) AND S<=(279) AND CHECK((D*8)+8)=1 THEN COL=0:CHECK((D*8)+8)=0:C=7:GOTO LineDraw
  383.  
  384. LineDraw:
  385.         LINE(201+C*10,51+D*10)-(209+C*10,59+D*10),COL,BF
  386.         NEXT C
  387.         GOTO WL2
  388.  
  389. ClearBox:
  390.        LINE (x,Y)-(x+(box*box),Y+(box*box)),0,BF
  391.        GOTO CL2
  392.  
  393. SaveLetter:
  394. GET (x,Y)-(X2,Y2),p%
  395. COLOR 5,1
  396. INPUT "Do you wish to SAVE the letter to Disk ( [Y]es [N]o )",sd$
  397. IF sd$ = "y" OR sd$ = "Y" THEN
  398. COLOR 6,1
  399. INPUT "Give it a File Name ",FIN$
  400. OPEN FIN$ FOR OUTPUT AS 1
  401. FOR x=0 TO ls
  402. PRINT#1,MKI$(p%(x));
  403. NEXT x
  404. CLOSE 1
  405. END IF
  406. COLOR 3,0
  407. CLS
  408. PRINT "The BINARY  values of each line can be found in the contents of the CHECK()"
  409. PRINT
  410. PRINT "And these are:-"
  411. PRINT:v$="":COLOR 4,0
  412. PRINT "          BINARY               HEX          DECIMAL"
  413. COLOR 1,0
  414. FOR Y=0 TO 7
  415. LOCATE 7+Y,10
  416. FOR x=1 TO 8
  417. v$=v$+ RIGHT$(STR$(CHECK((Y*8)+x)),1)
  418. NEXT x
  419. de1=VAL(LEFT$(v$,1))*128
  420. de2=VAL(MID$(v$,2,1))*64
  421. de3=VAL(MID$(v$,3,1))*32
  422. de4=VAL(MID$(v$,4,1))*16
  423. de5=VAL(MID$(v$,5,1))*8
  424. de6=VAL(MID$(v$,6,1))*4
  425. de7=VAL(MID$(v$,7,1))*2
  426. de8=VAL(RIGHT$(v$,1))*1
  427. deci=de1+de2+de3+de4+de5+de6+de7+de8
  428. PRINT v$," = &H"HEX$(deci)," = ";
  429. PRINT USING "###";deci
  430. v$=""
  431.  
  432. NEXT Y
  433. GOSUB PageTurn
  434. CLS
  435.  
  436. PutLetter:
  437. CLS
  438. INPUT "Do you want a Letter from Disk ( [Y]es [N]o ). ",gd$
  439. IF gd$ = "y" OR gd$ = "Y" THEN
  440. INPUT "Which File Name ",FIN$
  441. OPEN FIN$ FOR INPUT AS 1
  442. FOR x = 0 TO ls
  443. p%(x) = CVI(INPUT$(2,1))
  444. NEXT x
  445. CLOSE 1
  446. END IF
  447. CLS
  448. PALETTE 2,0,0,0
  449. FOR x=1 TO 5
  450.  
  451. PUT (x*100,40),p%
  452. NEXT x
  453. GOSUB PageTurn
  454.  
  455. PALETTE 2,.5,0,0
  456. GOTO MakeLetter
  457.  
  458. ENDIT:
  459. CLS
  460.        Font "Diamond.Font",20,0,0
  461.        LOCATE 5,15:COLOR 7,0
  462.        PRINT "The End"
  463.        Font "topaz.font",8,0,0
  464. GOSUB PageTurn
  465.  
  466.        WINDOW CLOSE 2
  467.        SCREEN CLOSE 1
  468.        LIBRARY CLOSE
  469.        SYSTEM
  470.  
  471. PageTurn:
  472. LOCATE 28,15:INPUT "Press RETURN to turn Page           ",dum$
  473. RETURN
  474.  
  475. SUB Font(fontName$, height%, style%, prefs%) STATIC
  476.   SHARED pfont&
  477.   IF pfont&<>0 THEN CALL CloseFont(pfont&)
  478.   fontName0$=fontName$+CHR$(0)
  479.   textAttr&(0)=SADD(fontName0$)
  480.   textAttr&(1)=height%*65536& + style%*256 + prefs%
  481.   pfont&=OpenDiskFont&(VARPTR(textAttr&(0)))
  482.   IF pfont& <> 0 THEN SetFont WINDOW(8),pfont&
  483. END SUB
  484.  
  485. SUB SetStyle(mask%) STATIC
  486.   SHARED enable%
  487.   SetSoftStyle WINDOW(8),mask%,enable%
  488. END SUB
  489.  
  490.